home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / encorsrc.lha / encore_sources / sys / readtable.t < prev    next >
Text File  |  1988-05-02  |  6KB  |  146 lines
  1. (herald readtable (env tsys))
  2.  
  3. ;;; Copyright (c) 1985 Yale University
  4. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  5. ;;; This material was developed by the T Project at the Yale University Computer 
  6. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  7. ;;; and to use it for any purpose is granted, subject to the following restric-
  8. ;;; tions and understandings.
  9. ;;; 1. Any copy made of this software must include this copyright notice in full.
  10. ;;; 2. Users of this software agree to make their best efforts (a) to return
  11. ;;;    to the T Project at Yale any improvements or extensions that they make,
  12. ;;;    so that these may be included in future releases; and (b) to inform
  13. ;;;    the T Project of noteworthy uses of this software.
  14. ;;; 3. All materials developed as a consequence of the use of this software
  15. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  16. ;;;    of acknowledging credit in academic research.
  17. ;;; 4. Yale has made no warrantee or representation that the operation of
  18. ;;;    this software will be error-free, and Yale is under no obligation to
  19. ;;;    provide any services, by way of maintenance, update, or otherwise.
  20. ;;; 5. In conjunction with products arising from the use of this material,
  21. ;;;    there shall be no use of the name of the Yale University nor of any
  22. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  23. ;;;    without prior written consent from Yale in each case.
  24. ;;;
  25.  
  26. ;;;; read-table manipulation
  27.  
  28. ;;; read tables consist of data which drives read and print.
  29.  
  30. ;;; output control:
  31.  
  32.  
  33. ;;; for now, the read table is a vector with one entry for each ascii
  34. ;;; character.  each such entry can be either a procedure, in which case the
  35. ;;; character is a procedure for a read macro, or (the value of) one of:
  36. ;;;   %%whitespace
  37. ;;;   %%ignored
  38. ;;;   %%constituent
  39. ;;;   %%escape-char
  40. ;;;   %%undefined
  41. ;;; thanks to common lisp (i.e. steele) for the general shape of the thing.
  42.  
  43. (define-constant %%whitespace  0)
  44. (define-constant %%ignored     1)
  45. (define-constant %%constituent 2)
  46. (define-constant %%escape-char 3)
  47. (define-constant %%undefined   4)
  48.  
  49. (define-integrable (read-macro? syn) (not (fixnum? syn)))       ; hack!
  50.  
  51. (define-integrable (read-table? obj) (rt? obj))
  52.  
  53. ;;; the read table structure type.
  54.  
  55. (define-structure-type rt
  56.   id                ; identification
  57.   mutable?          ; true if writable
  58.   vector            ; vector with one entry per ascii code
  59.   translator        ; consituent translation function for atom scan
  60.   string->symbol    ; thing to call if there are slashified chars  (???)
  61.   radix             ; input radix
  62.   recognizer        ; atom recognation functional  (???)
  63.   keyword-table     ; keyword table for #[...]
  64.   (((set-immutable rt)  (set (rt-mutable? rt) nil))
  65.    ((mutable? rt)       (rt-mutable? rt))
  66.    ((identification rt) (rt-id rt))
  67.    ((print rt port)
  68.     (format port "#{Read-table~_~s~_~s}" (object-hash rt) (rt-id rt)))))
  69.  
  70. (define-integrable (char-syntax rt ch)
  71.   (vref (rt-vector rt) (char->ascii ch)))
  72.  
  73. (define vanilla-read-table
  74.   (let ((rt (make-rt)))
  75.     (set (rt-id rt)         'vanilla-read-table)
  76.     (set (rt-mutable? rt)   nil)
  77.     (set (rt-vector rt)
  78.          (let ((v (vector-fill (make-vector number-of-char-codes)
  79.                                %%undefined)))
  80.            (do ((i 0 (fx+ i 1)))
  81.                ((fx>= i number-of-char-codes))
  82.              (cond ((graphic? (ascii->char i))  ; careful - don't be circular
  83.                     (set (vref v i) %%constituent))))
  84.            (walk (lambda (ch)
  85.                    (set (vref v (char->ascii ch)) %%whitespace))
  86.                  '(#\space #\return #\linefeed #\tab #\form))
  87.            (set (vref v (char->ascii #\rubout)) %%ignored)
  88.            (set (vref v (char->ascii #\escape)) %%constituent) ; pacify mit?
  89.            v))
  90.     (set (rt-translator rt)     %char-upcase)
  91.     (set (rt-string->symbol rt) string->symbol)
  92.     (set (rt-radix rt)          10)
  93.     (set (rt-recognizer rt)     recognize-atom)
  94.     rt))
  95.  
  96. (define (make-read-table super id)
  97.   (let ((rt (copy-structure (enforce read-table? super)))
  98.         (new (make-vector number-of-char-codes)))
  99.     (set (rt-id rt) id)
  100.     (set (rt-mutable? rt) t)
  101.     (do ((i 0 (fx+ i 1)))
  102.         ((fx>= i number-of-char-codes)
  103.          (set (rt-vector rt) new)
  104.          rt)
  105.       (let ((z (vref (rt-vector rt) i)))
  106.         (set (vref new i)
  107.              (cond ((read-macro? z) (copy-read-table-entry z))
  108.                    (else z)))))))
  109.  
  110. (define-operation (copy-read-table-entry syn) syn)
  111.  
  112. (define read-table-entry
  113.   (object (lambda (rt ch)
  114.             (char-syntax rt (enforce char? ch)))
  115.           ((setter self)
  116.            (lambda (rt ch val)
  117.              (cond ((rt-mutable? rt)
  118.                     (set (vref (rt-vector rt) (char->ascii (enforce char? ch)))
  119.                          val))
  120.                    (else
  121.                     (error "attempt to alter an immutable read-table~%  ~s"
  122.                            `(set (read-table-entry ,self ,ch) ,val))))))))
  123.  
  124. (define set-read-table-entry (setter read-table-entry))
  125.  
  126. ;++ This seems like a wierd default method.
  127. (define-operation (establish-read-table-entry val ch)
  128.   (cond ((and (eq? val %%escape-char) (null? *escape-char*))
  129.          (set *escape-char* ch))))
  130.  
  131. (define-predicate delimiting-read-macro?)
  132.  
  133. (define (constituent-syntax? e)     ; used by print - can go away some day
  134.   (cond ((fixnum? e)
  135.          (fx= e %%constituent))
  136.         (else
  137.          (not (delimiting-read-macro? e)))))
  138.  
  139. ;;; hack for reading/printing in different radices.
  140. ;;; if consing is a worry, pool these things.
  141.  
  142. (define (rt-with-radix rt radix)
  143.   (let ((new-rt (copy-structure rt)))
  144.     (set (rt-radix new-rt) radix)
  145.     new-rt))
  146.